COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00021 ENDMK
C⊗;


(DEFPROP SYS1FNS
 (SYS1FNS (NOCALL SELECTQ1 SUBPR MEMCDR)
	  (SPECIAL %PREVFN% $%DOTFLG LPTLENGTH GRINPROPS FILBAK)
	  DIR
	  *RENAME
	  FILBAK
	  %DEFINE
	  DE
	  DF
	  DM
	  %DEREAD
	  DRM
	  DSM
	  %DEVP
	  %READIN
	  DSKIN
	  PUTSYM
	  GETSYM
	  DSKOUT
	  LPTLENGTH
	  GRINL
	  TCONC
	  LCONC
	  DREVERSE
	  REMOVE
	  DREMOVE
	  TAILP
	  ASSOC#
	  PRINTLEV
	  PRINLEV
	  MEMCDR
	  %PREVFN%
	  %LOOKDPTH
	  $%DOTFLG
	  LSUBST
	  SELECTQ
	  SELECTQ1
	  SUBLIS
	  SUBPAIR
	  SUBPR
	  DSUBST
	  RETFROM
	  LDIFF
	  NTH
	  SUBST
	  RPUTSYM
	  RGETSYM
	  COPY
	  GRINDEF
	  GRINPROPS
	  FILBAK)
VALUE)

(NOCALL SELECTQ1 SUBPR MEMCDR)

(SPECIAL %PREVFN% $%DOTFLG LPTLENGTH GRINPROPS FILBAK)

(DEFPROP DIR
 (LAMBDA(%UFD)
  (SETQ %UFD (INC (UFDINP (GENSYM) %UFD) NIL))
  (PROG	(%LIST %FILE)
   LOOP	(COND ((ATOM (SETQ %FILE (ERRSET (RDFILE)))) (INC %UFD T) (RETURN %LIST)))
	(SETQ %LIST (CONS (CAR %FILE) %LIST))
	(GO LOOP)))
EXPR)

(DEFPROP *RENAME
 (LAMBDA (X Y) (EVAL (CONS (QUOTE RENAME) (APPEND X Y))))
EXPR)

(DEFPROP FILBAK
 (LAMBDA(FILE BAK)
  (PROG	(FILNAM)
	(COND ((ATOM FILE) (SETQ FILNAM (CAR (SETQ FILE (NCONS FILE)))))
	      ((AND (ATOM (CDR FILE))) (SETQ FILNAM (CAAR (SETQ FILE (NCONS FILE)))))
	      (T (SETQ FILNAM (CADR FILE)) (OR (ATOM FILNAM) (SETQ FILNAM (CAR FILNAM)))))
	(RETURN (*RENAME FILE (NCONS (CONS FILNAM BAK))))))
EXPR)

(DEFPROP FILBAK
 (NIL . LBK)
VALUE)

(DEFPROP %DEFINE
 (LAMBDA(X V F P)
  (PROG	(R)
	(SETQ R (COND ((GETL X (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO))) 
			(LIST X (QUOTE REDEFINED))) (T X)))
	(PUTPROP X (CONS (QUOTE LAMBDA) (CONS V F)) P)
	(RETURN R)))
EXPR)

(DEFPROP DE
 (LAMBDA (L) (%DEFINE (CAR L) (CADR L) (CDDR L) (QUOTE EXPR)))
FEXPR)

(DEFPROP DF
 (LAMBDA (L) (%DEFINE (CAR L) (CADR L) (CDDR L) (QUOTE FEXPR)))
FEXPR)

(DEFPROP DM
 (LAMBDA (L) (%DEFINE (CAR L) (CADR L) (CDDR L) (QUOTE MACRO)))
FEXPR)

(DEFPROP %DEREAD
 (LAMBDA(CHAR FUNC BITS)
  (SETQ CHAR (INTERN (ASCII CHAR)))
  (PUTPROP CHAR FUNC (QUOTE READMACRO))
  (SETCHR CHAR BITS)
  (CHRVAL CHAR))
EXPR)

(DEFPROP DRM
 (LAMBDA (L) (ASCII (%DEREAD (CHRVAL (CAR L)) (CADR L) 12)))
FEXPR)

(DEFPROP DSM
 (LAMBDA (L) (ASCII (%DEREAD (CHRVAL (CAR L)) (CADR L) 13)))
FEXPR)

(DEFPROP %DEVP
 (LAMBDA (X) (OR (EQ (NTHCHAR X -1) (QUOTE :)) (AND (CONSP X) (CONSP (CDR X)))))
EXPR)

(DEFPROP %READIN
 (LAMBDA(CHAN PRINT)
  (PROG	(OLDCHAN SEXPR)
	(SETQ OLDCHAN (INC CHAN NIL))
   LOOP	(SETQ SEXPR (ERRSET (READ) T))
	(COND ((ATOM SEXPR) (GO END)))
	(SETQ SEXPR (EVAL (CAR SEXPR)))
	(COND (PRINT (PRINT SEXPR)))
	(GO LOOP)
   END	(INC OLDCHAN T)
	(RETURN NIL)))
EXPR)

(DEFPROP DSKIN
 (LAMBDA(%L)
  (PROG	(%CH)
	(SETQ %CH (EVAL (CONS (QUOTE INPUT) (CONS (GENSYM) %L))))
	(%READIN %CH T)
	(RETURN (QUOTE FILES-LOADED))))
FEXPR)

(DEFPROP PUTSYM
 (LAMBDA(L)
  (MAPC (FUNCTION (LAMBDA (X) (COND ((ATOM X) (*PUTSYM X X)) (T (*PUTSYM (CAR X) (EVAL (CADR X))))))) L))
FEXPR)

(DEFPROP GETSYM
 (LAMBDA(L0)
  (MAPCAR (FUNCTION
	   (LAMBDA(X)
	    (PROG (V)
		  (SETQ V (*GETSYM X))
		  (COND	(V (PUTPROP X (NUMVAL V) (CAR L0)))
			(T (PRINT X) (PRINC (QUOTE NOT/ IN/ SYMBOL/ TABLE))))
		  (RETURN V))))
	  (CDR L0)))
FEXPR)

(DEFPROP DSKOUT
 (LAMBDA(%%L)
  (PROG	(%%D)
	(COND ((%DEVP (SETQ %%D (CAR %%L))) (SETQ %%L (CDR %%L))) (T (SETQ %%D (QUOTE DSK:))))
	(COND
	 ((AND FILBAK (LOOKUP %%D (CAR %%L)) (NULL (FILBAK (LIST %%D (CAR %%L)) FILBAK)))
	  (PRINC (QUOTE NO/ BACKUP/ ))
	  (PRINC (CAR %%L))
	  (TERPRI)))
	(SETQ %%D (OUTC (EVAL (LIST (QUOTE OUTPUT) (GENSYM) %%D (CAR %%L))) NIL))
	(LINELENGTH LPTLENGTH)
   L1	(COND
	 ((SETQ %%L (CDR %%L))
	  (COND ((ATOM (CAR %%L)) (EVAL (LIST (QUOTE GRINL) (CAR %%L)))) (T (EVAL (CAR %%L))))
	  (GO L1)))
	(OUTC NIL T)))
FEXPR)

(DEFPROP LPTLENGTH
 (NIL . 160)
VALUE)

(DEFPROP GRINL
 (LAMBDA(%L)
  (PROG	(%X %Y %Z)
   L1	(COND ((NULL %L) (RETURN NIL)))
	(SETQ %X (EVAL (CAR %L)))
	(APPLY# (QUOTE GRINDEF) (CONS (CAR %L) %X))
   L3	(COND ((NULL %X) (GO L2)))
	(SETQ %Y (CAR %X))
	(COND
	 ((SETQ %Z (GET %Y (QUOTE READMACRO)))
	  (TERPRI)
	  (SPRINT (LIST (QUOTE %DEREAD) (CHRVAL %Y) (LIST (QUOTE FUNCTION) %Z) (SETCHR %Y NIL)) 1)
	  (TERPRI)))
	(SETQ %X (CDR %X))
	(GO L3)
   L2	(SETQ %L (CDR %L))
	(GO L1)))
FEXPR)

(DEFPROP TCONC
 (LAMBDA(P X)
  (COND	((NULL P) (CONS (SETQ X (NCONS X)) X))
	((ATOM P) (PRINT P) (ERROR (QUOTE BAD/ ARGUMENT/ -/ TCONC)))
	((CDR P) (RPLACD P (CDR (RPLACD (CDR P) (NCONS X)))))
	(T (RPLACA (RPLACD P (SETQ X (NCONS X))) X))))
EXPR)

(DEFPROP LCONC
 (LAMBDA(PTR X)
  (PROG	(XX)
	(COND ((NULL X) (RETURN PTR))
	      ((OR (ATOM X) (CDR (SETQ XX (LAST X)))) (PRINT X) (GO ERROR))
	      ((NULL PTR) (RETURN (CONS X XX)))
	      ((ATOM PTR) (PRINT PTR) (GO ERROR))
	      ((NULL (CAR PTR)) (RETURN (RPLACA (RPLACD PTR XX) X)))
	      (T (RPLACD (CDR PTR) X) (RETURN (RPLACD PTR XX))))
   ERROR(ERROR (QUOTE BAD/ ARGUMENT/ -/ LCONC))))
EXPR)

(DEFPROP DREVERSE
 (LAMBDA(L)
  (PROG (Y Z) L1 (COND ((ATOM (SETQ Y L)) (RETURN Z))) (SETQ L (CDR L)) (SETQ Z (RPLACD Y Z)) (GO L1)))
EXPR)

(DEFPROP REMOVE
 (LAMBDA(ELT LIST)
  (COND	((ATOM LIST) LIST)
	((EQUAL (CAR LIST) ELT) (REMOVE ELT (CDR LIST)))
	((CONS (CAR LIST) (REMOVE ELT (CDR LIST))))))
EXPR)

(DEFPROP DREMOVE
 (LAMBDA(X L)
  (COND	((ATOM L) NIL)
	((EQ X (CAR L)) (COND ((CDR L) (RPLACA L (CADR L)) (RPLACD L (CDDR L)) (DREMOVE X L))))
	(T
	 (PROG (Z)
	       (SETQ Z L)
	  LP   (COND ((ATOM (CDR L)) (RETURN Z)) ((EQ X (CADR L)) (RPLACD L (CDDR L))) (T (SETQ L (CDR L))))
	       (GO LP)))))
EXPR)

(DEFPROP TAILP
 (LAMBDA(X Y)
  (AND# X (PROG NIL LP (COND ((ATOM Y) (RETURN NIL)) ((EQ X Y) (RETURN X))) (SETQ Y (CDR Y)) (GO LP))))
EXPR)

(DEFPROP ASSOC#
 (LAMBDA(A B)
  (PROG NIL L1 (COND ((NULL B) (RETURN NIL)) ((EQUAL A (CAAR B)) (RETURN (CAR B)))) (SETQ B (CDR B)) (GO L1)))
EXPR)

(DEFPROP PRINTLEV
 (LAMBDA ($%X $%N) (TERPRI) (PRINLEV $%X $%N) $%X)
EXPR)

(DEFPROP PRINLEV
 (LAMBDA($%X $%N)
  (COND	((PATOM $%X) (PRIN1 $%X))
	((EQ %PREVFN% $%X) (PRINC (QUOTE \#\/ )))
	((EQ $%N 0) (PRINC (QUOTE &/ )))
	(T
	 (PROG ($%KK $%CL)
	       (PRINC (COND ($%DOTFLG (SETQ $%DOTFLG NIL) (QUOTE /./././ )) (T (QUOTE /())))
	       (PRINLEV (CAR $%X) (SUB1 $%N))
	       (SETQ $%KK $%X)
	  LP   (COND
		((MEMCDR $%X $%KK) (COND ($%CL (PRINC (QUOTE / /./././])) (RETURN NIL)) (T (SETQ $%CL T)))))
	       (COND ((NOT (EQ (CDR $%KK) (UNBOUND))) (SETQ $%KK (CDR $%KK)))
		     (T (PRINC (QUOTE / /./ UNBOUND/))) (RETURN NIL)))
	       (COND ((NULL $%KK) (PRINC (QUOTE /))) (RETURN NIL))
		     ((PATOM $%KK) (PRINC (QUOTE / /./ )) (PRIN1 $%KK) (PRINC (QUOTE /))) (RETURN NIL)))
	       (PRINC (QUOTE / ))
	       (COND ((NOT (PATOM (CAR $%KK))) (PRINLEV (CAR $%KK) (SUB1 $%N))) (T (PRIN1 (CAR $%KK))))
	       (GO LP)))))
EXPR)

(DEFPROP MEMCDR
 (LAMBDA(%X% %Y%)
  (PROG NIL L1 (COND ((EQ %X% (CDR %Y%)) (RETURN T)) ((EQ %X% %Y%) (RETURN NIL))) (SETQ %X% (CDR %X%)) (GO L1)))
EXPR)

(DEFPROP %PREVFN%
 (NIL . " ")
VALUE)

(DEFPROP %LOOKDPTH
 (NIL . 6)
VALUE)

(DEFPROP $%DOTFLG
 (NIL)
VALUE)

(DEFPROP LSUBST
 (LAMBDA(X Y Z)
  (COND	((NULL Z) NIL)
	((PATOM Z) (COND ((EQ Y Z) X) (T Z)))
	((EQUAL Y (CAR Z)) (NCONC (COPY X) (LSUBST X Y (CDR Z))))
	(T (CONS (LSUBST X Y (CAR Z)) (LSUBST X Y (CDR Z))))))
EXPR)

(DEFPROP SELECTQ
 (LAMBDA (SELCQ) (APPLY# (QUOTE PROGN) (SELECTQ1 (EVAL (CAR SELCQ)) (CDR SELCQ))))
FEXPR)

(DEFPROP SELECTQ
 (NIL . RETURN)
VALUE)

(DEFPROP SELECTQ1
 (LAMBDA(M L)
  (PROG	(C)
   LP	(SETQ C L)
	(COND ((NULL (SETQ L (CDR L))) (RETURN C))
	      ((OR (EQ (CAR (SETQ C (CAR C))) M) (AND (CONSP (CAR C)) (MEMQ M (CAR C)))) (RETURN (CDR C))))
	(GO LP)))
EXPR)

(DEFPROP SUBLIS
 (LAMBDA (ALST EXPR) (COND (ALST (SUBPR EXPR ALST NIL)) (T EXPR)))
EXPR)

(DEFPROP SUBPAIR
 (LAMBDA (OLD NEW EXPR) (COND (OLD (SUBPR EXPR OLD (OR# NEW (QUOTE (NIL))))) (T EXPR)))
EXPR)

(DEFPROP SUBPR
 (LAMBDA(EXPR L1 L2)
  (PROG	(D A)
	(COND ((ATOM EXPR) (GO LP)) ((SETQ D (CDR EXPR)) (SETQ D (SUBPR D L1 L2))))
	(SETQ A (SUBPR (CAR EXPR) L1 L2))
	(RETURN (COND ((OR (NEQ A (CAR EXPR)) (NEQ D (CDR EXPR))) (CONS A D)) (T EXPR)))
   LP	(COND ((NULL L1) (RETURN EXPR))
	      (L2 (COND ((EQ EXPR (CAR L1)) (RETURN (CAR L2)))))
	      (T (COND ((EQ EXPR (CAAR L1)) (RETURN (CDAR L1))))))
	(SETQ L1 (CDR L1))
	(AND L2 (SETQ L2 (OR# (CDR L2) (QUOTE (NIL)))))
	(GO LP)))
EXPR)

(DEFPROP DSUBST
 (LAMBDA(X Y Z)
  (PROG	(B)
	(COND ((EQ Y (SETQ B Z)) (RETURN (COPY X))))
   LP	(COND ((PATOM Z) (RETURN B))
	      ((COND ((LITATOM Y) (EQ Y (CAR Z))) (T (EQUAL Y (CAR Z)))) (RPLACA Z (COPY X)))
	      (T (DSUBST X Y (CAR Z))))
	(COND ((AND Y (EQ Y (CDR Z))) (RPLACD Z (COPY X)) (RETURN B)))
	(SETQ Z (CDR Z))
	(GO LP)))
EXPR)

(DEFPROP RETFROM
 (LAMBDA(FUN VAL)
  (COND	((SETQ FUN (STKSRCH FUN (SPDLPT) NIL)) (OUTVAL FUN VAL))
	(T (PRINT FUN) (ERROR (QUOTE NO/ EVAL/ BLIP/ -/ RETFROM)))))
EXPR)

(DEFPROP LDIFF
 (LAMBDA(X Y)
  (COND	((EQ X Y) NIL)
	((NULL Y) X)
	(T
	 (PROG (V Z)
	       (SETQ Z (SETQ V (NCONS (CAR X))))
	  LOOP (SETQ X (CDR X))
	       (COND ((EQ X Y) (RETURN Z)) ((NULL X) (ERROR (QUOTE NOT/ A/ TAIL/ -/ LDIFF))))
	       (SETQ V (CDR (RPLACD V (NCONS (CAR X)))))
	       (GO LOOP)))))
EXPR)

(DEFPROP NTH
 (LAMBDA(X N)
  (COND	((*GREAT 1 N) (CONS NIL X))
	(T
	 (PROG NIL LP (COND ((OR (ATOM X) (EQ N 1)) (RETURN X))) (SETQ X (CDR X)) (SETQ N (SUB1 N)) (GO LP)))))
EXPR)

(DEFPROP SUBST
 (LAMBDA (X Y S) (COND ((EQUAL Y S) X) ((ATOM S) S) (T (CONS (SUBST X Y (CAR S)) (SUBST X Y (CDR S))))))
EXPR)

(DEFPROP RPUTSYM
 (LAMBDA(L)
  (MAPC (FUNCTION (LAMBDA (X) (COND ((ATOM X) (*RPUTSYM X X)) (T (*RPUTSYM (CAR X) (EVAL (CADR X))))))) L))
FEXPR)

(DEFPROP RGETSYM
 (LAMBDA(L0)
  (MAPCAR (FUNCTION
	   (LAMBDA(X)
	    (PROG (V)
		  (SETQ V (*RGETSYM X))
		  (COND	(V (PUTPROP X (NUMVAL V) (CAR L0)))
			(T (PRINT X) (PRINC (QUOTE NOT/ IN/ SYMBOL/ TABLE))))
		  (RETURN V))))
	  (CDR L0)))
FEXPR)

(DEFPROP COPY
 (LAMBDA (X) (SUBST 0 0 X))
EXPR)

(DEFPROP GRINDEF
 (LAMBDA(%%L)
  (PROG	(%%F %%G T1)
   A	(COND ((NULL %%L) (TERPRI) (RETURN NIL)))
	(COND
	 ((CONSP (SETQ %%F (CAR %%L)))
	  (TERPRI)
	  (TERPRI)
	  (COND	((AND (CONSP (CAR %%F)) (EQ (CAAR %%F) (QUOTE LAP)))
		 (PRIN1 (CAR %%F))
		 (MAPC (FUNCTION (LAMBDA (X) (TAB (COND ((AND X (ATOM X)) 1) (T 10))) (SETQ %%F (PRIN1 X))))
		       (CDR %%F))
		 (COND (%%F (TAB 10) (PRIN1 NIL))))
		(T (SPRINT %%F 1)))
	  (GO D)))
	(SETQ %%F GRINPROPS)
   C	(COND
	 ((AND#	(SETQ %%G (GET (CAR %%L) (CAR %%F)))
		(OR# (PATOM %%G)
		     (COND ((AND# (EQ (CAR %%G) (QUOTE LAMBDA))
				  (CONSP (CADDR %%G))
				  (EQ (CAADDR %%G) (QUOTE BREAK1))
				  (MEMQ (CAR %%F) (QUOTE (EXPR FEXPR MACRO)))
				  (SETQ T1 (GET (CAR %%L) (QUOTE TRACE))))
			    (AND# (SETQ T1 (GETL (CDR T1) (QUOTE (EXPR FEXPR MACRO)))) (SETQ %%G (CADR T1))))
			   ((NEQ (CDR %%G) (UNBOUND))))))
	  (TERPRI)
	  (TERPRI)
	  (PRINC (QUOTE /(DEFPROP/ ))
	  (PRIN1 (CAR %%L))
	  (TERPRI)
	  (SPRINT %%G 2)
	  (TERPRI)
	  (PRIN1 (CAR %%F))
	  (PRINC (QUOTE /)))))
	(COND ((SETQ %%F (CDR %%F)) (GO C)))
   D	(SETQ %%L (CDR %%L))
	(GO A)))
FEXPR)

(DEFPROP GRINPROPS
 (NIL EXPR FEXPR MACRO VALUE SPECIAL)
VALUE)

(DEFPROP FILBAK
 (LAMBDA(FILE BAK)
  (PROG	(FILNAM)
	(COND ((ATOM FILE) (SETQ FILNAM (CAR (SETQ FILE (NCONS FILE)))))
	      ((AND (ATOM (CDR FILE))) (SETQ FILNAM (CAAR (SETQ FILE (NCONS FILE)))))
	      (T (SETQ FILNAM (CADR FILE)) (OR (ATOM FILNAM) (SETQ FILNAM (CAR FILNAM)))))
	(RETURN (*RENAME FILE (NCONS (CONS FILNAM BAK))))))
EXPR)

(DEFPROP FILBAK
 (NIL . LBK)
VALUE)